home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Languages / MS Cobol4.5 / DEMO / SSCNTRL.CBL < prev    next >
Text File  |  1991-04-08  |  3KB  |  59 lines
  1.       $set ans85 noosvs mf
  2.       *****************************************************************
  3.       *                                                               *
  4.       *              (C) Micro Focus Ltd. 1989                        *
  5.       *                                                               *
  6.       *                     SSCNTRL.CBL                               *
  7.       *                                                               *
  8.       * Demonstration of the use of dynamic attributes in screen      *
  9.       * section.  This example shows how to use the CONTROL clause    *
  10.       * in a screen section to indicate invalid fields after an       *
  11.       * accept statement.  Monochrome terminal users can also see     *
  12.       * the use of attribute strings to set reverse video; color      *
  13.       * terminal users can "uncomment" the line changing colors to    *
  14.       * view the use of attribute strings to set colors.             *
  15.       *****************************************************************
  16.  
  17.        working-storage section.
  18.        01 field1  pic x(4) value spaces.
  19.        01 field2  pic x(4) value spaces.
  20.        01 field3  pic x(4) value spaces.
  21.        01 attr-string  pic X(50).
  22.  
  23.        78 ws-reverse-video value 'reverse-video'.
  24.        78 ws-highlight    value 'highlight'.
  25.        78 ws-blink        value 'blink'.
  26.        78 ws-red-on-white value 'foreground-color 4 background-color 7'.
  27.  
  28.        screen section.
  29.        01 blank-screen blank screen.
  30.  
  31.        01 screen-1.
  32.            05 line 3 col 15
  33.                    value 'Fill the fields with data'.
  34.            05 line 6 col 20 value 'Field 1 : '.
  35.            05 pic xxxx using field1 auto-skip full required.
  36.            05 line 8 col 20 value 'Field 2 : '.
  37.            05 pic xxxx using field2
  38.                        control attr-string auto-skip full required.
  39.            05 line 10 col 20 value 'Field 3 : '.
  40.            05 pic xxxx using field3 required.
  41.  
  42.        01 error-screen.
  43.            05 line 24 col 10
  44.                    value 'Field 2 must contain ''9999'' to terminate'.
  45.  
  46.        procedure division.
  47.            display blank-screen
  48.            perform until field2 = '9999'
  49.                display screen-1
  50.                accept screen-1
  51.                if field2 not    = '9999'
  52.                    display error-screen
  53. *******            move ws-red-on-white  to attr-string
  54.                    move ws-reverse-video to attr-string
  55.                end-if
  56.            end-perform.
  57.            stop run.
  58.  
  59.